home *** CD-ROM | disk | FTP | other *** search
/ Aminet 52 / Aminet 52 (2002)(GTI - Schatztruhe)[!][Dec 2002].iso / Aminet / dev / gg / ncurses-5.3.lha / ncurses-5.3 / Ada95 / samples / ncurses2-util.adb < prev    next >
Text File  |  2002-10-24  |  7KB  |  200 lines
  1. ------------------------------------------------------------------------------
  2. --                                                                          --
  3. --                       GNAT ncurses Binding Samples                       --
  4. --                                                                          --
  5. --                               ncurses2.util                              --
  6. --                                                                          --
  7. --                                 B O D Y                                  --
  8. --                                                                          --
  9. ------------------------------------------------------------------------------
  10. -- Copyright (c) 2000 Free Software Foundation, Inc.                        --
  11. --                                                                          --
  12. -- Permission is hereby granted, free of charge, to any person obtaining a  --
  13. -- copy of this software and associated documentation files (the            --
  14. -- "Software"), to deal in the Software without restriction, including      --
  15. -- without limitation the rights to use, copy, modify, merge, publish,      --
  16. -- distribute, distribute with modifications, sublicense, and/or sell       --
  17. -- copies of the Software, and to permit persons to whom the Software is    --
  18. -- furnished to do so, subject to the following conditions:                 --
  19. --                                                                          --
  20. -- The above copyright notice and this permission notice shall be included  --
  21. -- in all copies or substantial portions of the Software.                   --
  22. --                                                                          --
  23. -- THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS  --
  24. -- OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF               --
  25. -- MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.   --
  26. -- IN NO EVENT SHALL THE ABOVE COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM,   --
  27. -- DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR    --
  28. -- OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR    --
  29. -- THE USE OR OTHER DEALINGS IN THE SOFTWARE.                               --
  30. --                                                                          --
  31. -- Except as contained in this notice, the name(s) of the above copyright   --
  32. -- holders shall not be used in advertising or otherwise to promote the     --
  33. -- sale, use or other dealings in this Software without prior written       --
  34. -- authorization.                                                           --
  35. ------------------------------------------------------------------------------
  36. --  Author: Eugene V. Melaragno <aldomel@ix.netcom.com> 2000
  37. --  Version Control
  38. --  $Revision: 1.1 $
  39. --  Binding Version 01.00
  40. ------------------------------------------------------------------------------
  41. with Terminal_Interface.Curses; use Terminal_Interface.Curses;
  42.  
  43. with Ada.Text_IO;
  44.  
  45. with Terminal_Interface.Curses; use Terminal_Interface.Curses;
  46. pragma Warnings (Off);
  47. with Terminal_Interface.Curses.Aux;
  48. pragma Warnings (On);
  49.  
  50. with Terminal_Interface.Curses.Trace; use Terminal_Interface.Curses.Trace;
  51.  
  52. with Ada.Text_IO; use Ada.Text_IO;
  53.  
  54. with Interfaces.C;
  55. with Interfaces.C.Strings;
  56.  
  57. with Ada.Characters.Handling;
  58.  
  59. with ncurses2.genericPuts;
  60.  
  61.  
  62. package body ncurses2.util is
  63.  
  64.    --  #defines from C
  65.    --  #define CTRL(x)         ((x) & 0x1f)
  66.    function CTRL (c : Character) return Key_Code is
  67.    begin
  68.       return Character'Pos (c) mod 16#20#;
  69.       --  uses a property of ASCII
  70.       --  A = 16#41#; a = 16#61#; ^A = 1 or 16#1#
  71.    end CTRL;
  72.  
  73.    function CTRL (c : Character) return Character is
  74.    begin
  75.       return Character'Val (Character'Pos (c) mod 16#20#);
  76.       --  uses a property of ASCII
  77.       --  A = 16#41#; a = 16#61#; ^A = 1 or 16#1#
  78.    end CTRL;
  79.  
  80.    save_trace : Trace_Attribute_Set;
  81.    --  Common function to allow ^T to toggle trace-mode in the middle of a test
  82.    --  so that trace-files can be made smaller.
  83.    function Getchar (win : Window := Standard_Window) return Key_Code is
  84.       c : Key_Code;
  85.    begin
  86.       --  #ifdef TRACE
  87.       c := Get_Keystroke (win);
  88.       while c = CTRL ('T') loop
  89.          --  if _nc_tracing  in C
  90.          if Current_Trace_Setting /= Trace_Disable then
  91.             save_trace := Current_Trace_Setting;
  92.             Trace_Put ("TOGGLE-TRACING OFF");
  93.             Current_Trace_Setting := Trace_Disable;
  94.          else
  95.             Current_Trace_Setting := save_trace;
  96.          end if;
  97.          Trace_On (Current_Trace_Setting);
  98.          if Current_Trace_Setting /= Trace_Disable then
  99.             Trace_Put ("TOGGLE-TRACING ON");
  100.          end if;
  101.       end loop;
  102.       --  #else c := Get_Keystroke;
  103.       return c;
  104.    end Getchar;
  105.  
  106.    procedure Getchar (win : Window := Standard_Window) is
  107.       x : Key_Code;
  108.    begin
  109.       x := Getchar (win);
  110.    end Getchar;
  111.  
  112.  
  113.    procedure Pause is
  114.    begin
  115.       Move_Cursor (Line => Lines - 1, Column => 0);
  116.       Add (Str => "Press any key to continue... ");
  117.       Getchar;
  118.    end Pause;
  119.  
  120.  
  121.    procedure Cannot (s : String) is
  122.       use Interfaces.C;
  123.       use Interfaces.C.Strings;
  124.       use Terminal_Interface.Curses.Aux;
  125.       function getenv (x : char_array)  return chars_ptr;
  126.       pragma Import (C, getenv, "getenv");
  127.       tmp1 : char_array (0 .. 10);
  128.       package p is new ncurses2.genericPuts (1024);
  129.       use p;
  130.       use p.BS;
  131.  
  132.       tmpb : BS.Bounded_String;
  133.  
  134.       Length : size_t;
  135.    begin
  136.       To_C ("TERM", tmp1, Length);
  137.       Fill_String (getenv (tmp1), tmpb);
  138.       Add (Ch => newl);
  139.       myAdd (Str => "This " & tmpb & " terminal " & s);
  140.       Pause;
  141.    end Cannot;
  142.  
  143.    procedure ShellOut (message : Boolean) is
  144.       use Interfaces.C;
  145.       Txt : char_array (0 .. 10);
  146.       Length : size_t;
  147.       procedure system (x : char_array);
  148.       pragma Import (C, system, "system");
  149.    begin
  150.       To_C ("sh", Txt,  Length);
  151.       if message then
  152.          Add (Str => "Shelling out...");
  153.       end if;
  154.       Save_Curses_Mode (Mode => Curses);
  155.       End_Windows;
  156.       system (Txt);
  157.       if message then
  158.          Add (Str => "returned from shellout.");
  159.          Add (Ch => newl);
  160.       end if;
  161.       Refresh;
  162.    end ShellOut;
  163.  
  164.  
  165.  
  166.    function Is_Digit (c : Key_Code) return Boolean is
  167.    begin
  168.       if c >= 16#100# then
  169.          return False;
  170.       else
  171.          return Ada.Characters.Handling.Is_Digit (Character'Val (c));
  172.       end if;
  173.    end Is_Digit;
  174.  
  175.    procedure P (s : String) is
  176.    begin
  177.       Add (Str => s);
  178.       Add (Ch => newl);
  179.    end P;
  180.  
  181.  
  182.    function Code_To_Char (c : Key_Code) return Character is
  183.    begin
  184.       if c > Character'Pos (Character'Last) then
  185.          return Character'Val (0);
  186.          --  maybe raise exception?
  187.       else
  188.          return Character'Val (c);
  189.       end if;
  190.    end Code_To_Char;
  191.  
  192.    --  This was untestable due to a bug in GNAT (3.12p)
  193.    --  Hmm, what bug? I don't remember.
  194.    function ctoi (c : Character) return Integer is
  195.    begin
  196.       return Character'Pos (c) - Character'Pos ('0');
  197.    end ctoi;
  198.  
  199. end ncurses2.util;
  200.